home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / kcl.lha / unixport / defsystem.lsp < prev    next >
Lisp/Scheme  |  1986-05-20  |  15KB  |  393 lines
  1. ;;;;    DEFSYSTEM.LSP
  2. ;;;;
  3. ;;;;    --- System Generation Tool for Kyoto Common Lisp ---
  4.  
  5.  
  6. (in-package 'lisp)
  7. (export '(defsystem defkcl defkcn))
  8. (in-package 'compiler)
  9. (in-package 'system)
  10.  
  11. ;;; *KCL-HOME-DIRECTORY*
  12. (defvar *kcl-home-directory* #"../")        ; Change!!
  13. (defvar *machine* 'sun3)            ; Change!!
  14.  
  15.  
  16. (defvar *unixport-directory*
  17.         (make-pathname :directory (append (pathname-directory
  18.                                            *kcl-home-directory*)
  19.                                           (list "unixport"))
  20.                        :name nil :type nil))
  21. (defvar *lsp-directory*
  22.         (make-pathname :directory (append (pathname-directory
  23.                                            *kcl-home-directory*)
  24.                                           (list "lsp"))
  25.                        :name nil :type nil))
  26. (defvar *o-directory*
  27.         (make-pathname :directory (append (pathname-directory
  28.                                            *kcl-home-directory*)
  29.                                           (list "o"))
  30.                        :name nil :type nil))
  31. (defvar *h-directory-file*
  32.         (make-pathname :directory (pathname-directory
  33.                                    *kcl-home-directory*)
  34.                        :name "h" :type nil))
  35.  
  36.  
  37. (setq *print-case* :downcase)
  38.  
  39.  
  40. (defvar *object-files*
  41.         '("main" "alloc" "gbc"
  42.           "bitop"
  43.           "typespec"
  44.           "eval" "macros" "lex" "bds" "frame"
  45.           "predicate"
  46.           "reference" "assignment" "bind" "let"
  47.           "conditional" "block" "iteration" "mapfun"
  48.           "prog" "multival" "catch"
  49.           "symbol" "cfun" "cmpaux" "package"
  50.           "big" "number" "num_pred" "num_comp" "num_arith" "num_sfun"
  51.           "num_co" "num_log" "num_rand" "earith"
  52.           "character" "char_table"
  53.           "sequence" "list" "hash" "array" "string" "structure"
  54.           "toplevel"
  55.           "file" "read" "backq" "print" "format" "pathname" "unixfsys"
  56.           "unixfasl"
  57.           "error"
  58.           "unixtime" "unixsys" "unixsave" "unixint"))
  59.  
  60. (defvar *lsp-object-files*
  61.         '("defmacro" "evalmacros" "top" "module"))
  62.  
  63. (defvar *all-libraries*
  64.         '("predlib" "setf"
  65.           "arraylib" "assert" "defstruct" "describe"
  66.           "iolib" "listlib" "mislib" "numlib"
  67.           "packlib" "seq" "seqlib" "trace"))
  68.  
  69.  
  70. (defun change-file-type (file type)
  71.   (make-pathname :directory (pathname-directory file)
  72.                  :name (pathname-name file)
  73.                  :type type))
  74.  
  75. (defun strip-file-type (file) (change-file-type file nil))
  76.  
  77. (defun search-tree (x tree)
  78.   (loop
  79.    (cond ((equal x tree) (return t))
  80.          ((atom tree) (return nil))
  81.          ((search-tree x (car tree)) (return t))
  82.          (t (setq tree (cdr tree))))))
  83.  
  84.  
  85. (defmacro defsystem (system-name files &rest body)
  86.   (if (atom system-name)
  87.       `(make-system ',system-name ',files ',body)
  88.       `(apply #'make-system
  89.               ',(car system-name) ',files ',body
  90.               ',(cdr system-name))))
  91.  
  92. (defun make-system (system-name files initial-forms
  93.                     &key (libraries nil)
  94.                          (system system-name)
  95.                          (top-level nil)
  96.                          (makefile "Makefile"))
  97.  
  98.   (cond ((eq libraries t) (setq libraries *all-libraries*)) 
  99.         (t
  100.          (dolist (library libraries)
  101.            (unless (member (string library) *all-libraries*
  102.                            :test #'string-equal)
  103.                    (error "~S is not a library." library)))
  104.          ;; Reorder the libraries.
  105.          (setq libraries
  106.                (mapcan #'(lambda (library)
  107.                            (if (member library libraries
  108.                                        :test #'string-equal :key #'string)
  109.                                (list library)
  110.                                nil))
  111.                        *all-libraries*))))
  112.  
  113.   (setq files
  114.         (mapcar #'(lambda (file)
  115.                     (if (symbolp file)
  116.                               (string-downcase (symbol-name file))
  117.                               file))
  118.                 files))
  119.  
  120.   (when (symbolp system-name)
  121.     (setq system-name (string-downcase (symbol-name system-name))))
  122.   (when (symbolp system)
  123.     (setq system (string-downcase (symbol-name system))))
  124.   (when (symbolp makefile)
  125.     (setq makefile (string-downcase (symbol-name makefile))))
  126.  
  127.   (unless (search-tree 'si:init-system initial-forms)
  128.     (setq initial-forms (append initial-forms (list '(si:init-system)))))
  129.  
  130.   (when top-level
  131.     (setq initial-forms
  132.           (append initial-forms
  133.                   (list `(defun si:top-level () (,top-level))))))
  134.  
  135.   ;; Make the sys file.
  136.   (with-open-file (stream (format nil "sys_~A.c" system-name)
  137.                    :direction :output)
  138.     (format stream "#include \"include.h\"~%~%")
  139.     (format stream "static object fasl_data;~%~%")
  140.     (format stream "init_init()~%{~%")
  141.     (format stream "    enter_mark_origin(&fasl_data);~%")
  142.     (format stream "    fasl_data = Cnil;~%~%")
  143.     (format stream "    load(\"~A\");~%"
  144.             (namestring (merge-pathnames "export.lsp" *lsp-directory*)))
  145.     (dolist (library *lsp-object-files*)
  146.       (format stream
  147.               "    fasl_data = read_fasl_data(\"~A\");~%"
  148.               (namestring
  149.                (merge-pathnames (change-file-type library "o")
  150.                                 *lsp-directory*)))
  151.       (format stream "    init_~A(NULL, 0, fasl_data);~%" library))
  152.     (format stream "    load(\"~A\");~%"
  153.             (namestring (merge-pathnames "autoload.lsp" *lsp-directory*)))
  154.     (format stream "}~%~%")
  155.     (format stream "init_system()~%{~%")
  156.     (dolist (library libraries)
  157.       (format stream
  158.               "    printf(\"Initializing ~A...  \");  fflush(stdout);~%"
  159.               library)
  160.       (format stream
  161.               "    fasl_data = read_fasl_data(\"~A\");~%"
  162.               (namestring
  163.                (merge-pathnames (change-file-type library
  164.                                                   "o")
  165.                                 *lsp-directory*)))
  166.       (format stream "    init_~A(NULL, 0, fasl_data);~%" library)
  167.       (format stream
  168.               "    printf(\"\\n\");  fflush(stdout);~%"))
  169.     (format stream "~%")
  170.     (dolist (file files)
  171.       (format stream
  172.               "    printf(\"Initializing ~A...  \");  fflush(stdout);~%"
  173.               (pathname-name file))
  174.       (format stream
  175.               "    Vpackage->s.s_dbind = user_package;~%")
  176.       (format stream
  177.               "    fasl_data = read_fasl_data(\"~A\");~%"
  178.               (namestring
  179.                (change-file-type file "o")))
  180.       (format stream "    init_~A(NULL, 0, fasl_data);~%"
  181.               (string-downcase (pathname-name file)))
  182.       (format stream
  183.               "    printf(\"\\n\");  fflush(stdout);~%"))
  184.     (format stream
  185.             "~%    Vpackage->s.s_dbind = user_package;~%")
  186.     (format stream "}~%"))
  187.  
  188.   ;; Make the init file.
  189.   (with-open-file (stream (format nil "init_~A.lsp" system-name)
  190.                    :direction :output)
  191.     (mapcar #'(lambda (package)
  192.                 (unless (eq package (find-package 'keyword))
  193.                         (prin1 `(IN-PACKAGE ,(package-name package)) stream)
  194.                         (terpri stream)))
  195.             (list-all-packages))
  196.     (prin1 `(IN-PACKAGE ,(package-name *package*)) stream)
  197.     (terpri stream)
  198.     (prin1 `(PROGN
  199.              ,@initial-forms
  200.              (SI:SAVE-SYSTEM ,(namestring (strip-file-type system)))
  201.              (BYE))
  202.            stream)
  203.     (terpri stream))
  204.  
  205.   ;; Make the makefile.
  206.   (with-open-file (stream makefile :direction :output)
  207.     (format stream "OBJS    = ~{~<\\~%    ~2,72:;~A~>~^ ~}~%~%"
  208.             (mapcar #'(lambda (object-file)
  209.                         (namestring
  210.                          (change-file-type (merge-pathnames object-file
  211.                                                             *o-directory*)
  212.                                            "o")))
  213.                     *object-files*))
  214.     (format stream "LSPOBJS    = ~{~<\\~%    ~2,72:;~A~>~^ ~}~%~%"
  215.             (mapcar #'(lambda (library)
  216.                         (namestring
  217.                          (change-file-type
  218.                           (merge-pathnames library *lsp-directory*) "o")))
  219.                     (append *lsp-object-files* libraries)))
  220.     (format stream "SYSOBJS = ~{~<\\~%    ~2,72:;~A~>~^ ~}~%~%"
  221.             (mapcar #'(lambda (file) (namestring (change-file-type file "o")))
  222.                     files))
  223.     (format stream "~A:    raw_~A init_~:*~A.lsp~%" system system-name)
  224.     (format stream "    raw_~A ~A < init_~A.lsp~%~%"
  225.             system-name (namestring *unixport-directory*) system-name)
  226.     (format stream "raw_~A:    $(OBJS) sys_~:*~A.o $(LSPOBJS)~%"
  227.             system-name)
  228.     (format stream "    cc -o raw_~A $(OBJS) sys_~:*~A.o ~
  229.             $(LSPOBJS) $(SYSOBJS) -lm~%~%"
  230.             system-name)
  231.     (format stream "sys_~A.o:    sys_~:*~A.c~%" system-name)
  232.     (format stream
  233.             "    cc -c -D~A -DMAXPAGE=16384 -DVSSIZE=2048 -I~A sys_~A.c~%"
  234.             (string-upcase (string *machine*))
  235.             (namestring *h-directory-file*)
  236.             system-name)))
  237.  
  238.  
  239. (defvar *cmpnew-directory*
  240.         (make-pathname :directory (append (pathname-directory
  241.                                            *kcl-home-directory*)
  242.                                           (list "cmpnew"))
  243.                        :name nil :type nil))
  244.  
  245.  
  246. (defvar *lisp-implementation-version*
  247.         (multiple-value-bind (sec min hour date month year)
  248.             (get-decoded-time)
  249.           (format nil "~A ~D, ~D"
  250.                   (case month
  251.                     (1 "January") (2 "Feburary") (3 "March")
  252.                     (4 "April") (5 "May") (6 "June")
  253.                     (7 "July") (8 "August") (9 "September")
  254.                     (10 "October") (11 "November") (12 "December"))
  255.                   date year)))
  256.  
  257.  
  258. (defmacro defkcl (&key (system-name "kcl")
  259.                        (system (format nil "saved_~a" (string system-name)))
  260.                        (include-compiler t)
  261.                        (libraries t)
  262.                        (makefile "Makefile")
  263.                   &aux (*package* *package*)
  264.                        )
  265.  
  266.   (in-package 'system)
  267.   (setq *check-time* nil)
  268.  
  269.   `(defsystem (,system-name
  270.                :top-level kcl-top-level
  271.                :libraries ,libraries
  272.                :system ,system
  273.                :makefile ,makefile)
  274.  
  275.              ,(if include-compiler
  276.                   (list (merge-pathnames "cmpinline" *cmpnew-directory*)
  277.                         (merge-pathnames "cmputil" *cmpnew-directory*)
  278.                         (merge-pathnames "cmptype" *cmpnew-directory*)
  279.                         (merge-pathnames "cmpbind" *cmpnew-directory*)
  280.                         (merge-pathnames "cmpblock" *cmpnew-directory*)
  281.                         (merge-pathnames "cmpcall" *cmpnew-directory*)
  282.                         (merge-pathnames "cmpcatch" *cmpnew-directory*)
  283.                         (merge-pathnames "cmpenv" *cmpnew-directory*)
  284.                         (merge-pathnames "cmpeval" *cmpnew-directory*)
  285.                         (merge-pathnames "cmpflet" *cmpnew-directory*)
  286.                         (merge-pathnames "cmpfun" *cmpnew-directory*)
  287.                         (merge-pathnames "cmpif" *cmpnew-directory*)
  288.                         (merge-pathnames "cmplabel" *cmpnew-directory*)
  289.                         (merge-pathnames "cmplam" *cmpnew-directory*)
  290.                         (merge-pathnames "cmplet" *cmpnew-directory*)
  291.                         (merge-pathnames "cmploc" *cmpnew-directory*)
  292.                         ;(merge-pathnames "cmpmain" *cmpnew-directory*)
  293.                         (merge-pathnames "cmpmap" *cmpnew-directory*)
  294.                         (merge-pathnames "cmpmulti" *cmpnew-directory*)
  295.                         (merge-pathnames "cmpspecial" *cmpnew-directory*)
  296.                         (merge-pathnames "cmptag" *cmpnew-directory*)
  297.                         (merge-pathnames "cmptop" *cmpnew-directory*)
  298.                         (merge-pathnames "cmpvar" *cmpnew-directory*)
  299.                         (merge-pathnames "cmpvs" *cmpnew-directory*)
  300.                         (merge-pathnames "cmpwt" *cmpnew-directory*))
  301.                   nil)
  302.  
  303.     (allocate 'cons 100)
  304.     (allocate 'string 40)
  305.  
  306.     (si:init-system)
  307.  
  308.     (gbc t)
  309.  
  310.     ,@(if include-compiler
  311.           `((load ,(merge-pathnames "cmpmain.lsp" *cmpnew-directory*))
  312.             (gbc t)
  313.             (load ,(merge-pathnames "lfun_list.lsp" *cmpnew-directory*))
  314.             (gbc t)
  315.             (load ,(merge-pathnames "cmpopt.lsp" *cmpnew-directory*))
  316.             (gbc t)
  317.             (defun compile-file (&rest args
  318.                                  &aux (*print-pretty* nil)
  319.                                       (*package* *package*))
  320.               (compiler::init-env)
  321.               (apply 'compiler::compile-file1 args))
  322.             (defun compile (&rest args &aux (*print-pretty* nil))
  323.               (apply 'compiler::compile1 args))
  324.             (defun disassemble (&rest args &aux (*print-pretty* nil))
  325.               (apply 'compiler::disassemble1 args)))
  326.           nil)
  327.  
  328.     (load ,(merge-pathnames "setdoc.lsp" *lsp-directory*))
  329.  
  330.     (setq *old-top-level* (symbol-function 'si:top-level))
  331.  
  332.     (defun kcl-top-level ()
  333.  
  334.       (when (> (si:argc) 1) (setq *system-directory* (si:argv 1)))
  335.  
  336.       ,@(if include-compiler
  337.             '((when (>= (si:argc) 5)
  338.                 (let ((si::*quit-tag* (cons nil nil))
  339.                       (si::*quit-tags* nil)
  340.                       (si::*break-level* 0)
  341.                       (si::*break-env* nil)
  342.                       (si::*ihs-base* 1)
  343.                       (si::*ihs-top* 1)
  344.                       (si::*current-ihs* 1)
  345.                       (*break-enable* nil))
  346.                   (si:error-set 
  347.                    '(let ((flags (si:argv 4)))
  348.                       (setq si:*system-directory* (pathname (si:argv 1)))
  349.                       (compile-file
  350.                        (si:argv 2)
  351.                        :output-file (si:argv 3)
  352.                        :o-file
  353.                        (case (schar flags 1)
  354.                          (#\0 nil) (#\1 t) (t (si:argv 5)))
  355.                        :c-file
  356.                        (case (schar flags 2)
  357.                          (#\0 nil) (#\1 t) (t (si:argv 6)))
  358.                        :h-file
  359.                        (case (schar flags 3)
  360.                          (#\0 nil) (#\1 t) (t (si:argv 7)))
  361.                        :data-file
  362.                        (case (schar flags 4)
  363.                          (#\0 nil) (#\1 t) (t (si:argv 8)))
  364.                        :system-p 
  365.                        (if (char-equal (schar flags 0) #\S) t nil))))
  366.                   (bye))))
  367.             nil)
  368.  
  369.       (format t "KCl (Kyoto Common Lisp)  ~A~%"
  370.               ,*lisp-implementation-version*)
  371.  
  372.       (in-package 'user)
  373.  
  374.       (funcall *old-top-level*))
  375.  
  376.     (defun lisp-implementation-version () ,*lisp-implementation-version*)
  377.  
  378.     (setq *modules* nil)
  379.  
  380.     (gbc t)
  381.  
  382.     (si:reset-gbc-count)
  383.  
  384.     (allocate 'cons 200)
  385.  
  386.     )
  387. )
  388.  
  389. (defmacro defkcn (&rest r)
  390.   `(defkcl :include-compiler nil
  391.            :system-name kcn
  392.            ,@r))
  393.